home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / pascal4 / pro11 / errtrace.pas < prev    next >
Pascal/Delphi Source File  |  1988-09-16  |  11KB  |  255 lines
  1. {
  2. ErrTrace - a unit for TurboPascal v4.0 to display an error traceback
  3.            information.
  4.  
  5. Author : Michal Jankowski <sieminski@rzsin.sin.ch>
  6.                           <sieminski%rzsin.sin.ch@cernvax> (Bitnet)
  7. Version : 1.0  16.09.1988
  8. }
  9.  
  10. {$N- No floating point needed }
  11. {$B- Boolean short circuit    }
  12. {$R- No range checking needed }
  13. {$D- No debug information     }
  14.  
  15. unit ErrTrace;
  16. {-----------------------------------------------------------------------------}
  17. interface
  18. const
  19.   Continue : boolean = false;
  20.  
  21. {-----------------------------------------------------------------------------}
  22. implementation
  23.  
  24. {
  25.   convert integer to hex
  26. }
  27. type
  28.   hexWord = string[4];
  29.  
  30. function hex( x : word ) : hexWord;
  31.   const hexDigit : array [0..15] of char = '0123456789ABCDEF';
  32. begin
  33.   hex := hexDigit[(x shr 12) and $f ] +
  34.          hexDigit[(x shr  8) and $f ] +
  35.          hexDigit[(x shr  4) and $f ] +
  36.          hexDigit[ x and $f ];
  37. end; { function hex }
  38.  
  39. const
  40.   FarCallOpcode  : byte = $9A;
  41.   NearCallOpcode : byte = $E8;
  42.   PushbpOpcode   : byte = $55;
  43.   MovbpspOpcode  : word = $E589;
  44.  
  45. var
  46.   NF      : char;       { 'N' for near, 'F' for far calls }
  47.   Errorcs,
  48.   Errorip,
  49.   newip,
  50.   adr,
  51.   newcs,
  52.   _cs,
  53.   _ip,
  54.   _bp      : word;
  55.   first,
  56.   found    : boolean;
  57.   ExitSave : pointer;
  58.  
  59. type
  60.   ErrorMsg    = record
  61.                   ErrTxt   : String[32]; { Longest message has 32 characters }
  62.                   ErrNo    : integer;
  63.                 end;
  64.  
  65. const
  66.   ErrorMsgSize = 26;         { Number of messages                            }
  67.   ErrorMsgs   : array[1..ErrorMsgSize] of ErrorMsg = (
  68. { Run-time error messages }
  69.     ( ErrTxt: 'Division by zero';                        ErrNo: 200 ),
  70.     ( ErrTxt: 'Range check error';                       ErrNo: 201),
  71.     ( ErrTxt: 'Stack overflow error';                    ErrNo: 202),
  72.     ( ErrTxt: 'Heap overflow error';                     ErrNo: 203),
  73.     ( ErrTxt: 'Invalid pointer operation';               ErrNo: 204),
  74.     ( ErrTxt: 'Floating point overflow';                 ErrNo: 205),
  75.     ( ErrTxt: 'Floating point underflow';                ErrNo: 206),
  76.     ( ErrTxt: 'Invalid floating point operation';        ErrNo: 207),
  77. { I/O error messages }
  78.     ( ErrTxt: 'File not found';                          ErrNo:   2),
  79.     ( ErrTxt: 'Path not found';                          ErrNo:   3),
  80.     ( ErrTxt: 'Too many open files';                     ErrNo:   4),
  81.     ( ErrTxt: 'File access denied';                      ErrNo:   5),
  82.     ( ErrTxt: 'Invalid file handle';                     ErrNo:   6),
  83.     ( ErrTxt: 'Invalid file access code';                ErrNo:  12),
  84.     ( ErrTxt: 'Invalid drive number';                    ErrNo:  15),
  85.     ( ErrTxt: 'Cannot remove current directory';         ErrNo:  16),
  86.     ( ErrTxt: 'Cannot rename across drives';             ErrNo:  17),
  87.     ( ErrTxt: 'Disk read error';                         ErrNo: 100),
  88.     ( ErrTxt: 'File not open';                           ErrNo: 103),
  89.     ( ErrTxt: 'File not open for input';                 ErrNo: 104),
  90.     ( ErrTxt: 'File not open for output';                ErrNo: 105),
  91.     ( ErrTxt: 'Invalid numeric format';                  ErrNo: 106),
  92.     ( ErrTxt: 'Disk write error';                        ErrNo: 101),
  93.     ( ErrTxt: 'File not assigned';                       ErrNo: 102),
  94.     ( ErrTxt: 'Drive not ready';                         ErrNo: 152),
  95.     ( ErrTxt: 'Unknown Error';                           ErrNo:   0));
  96.  
  97. {$f+}
  98. procedure ErrorTrap;
  99. {$f-}
  100.  
  101. var
  102.   i          : integer;      { Index to table of messages, also used to      }
  103.                              { the stack, must be the FIRST local variable   }
  104. begin
  105.   if (ExitCode<>0)           { only on error exits                           }
  106.   and (ExitCode<>255) then begin { not on user break                         }
  107. { Look for error number in table                                             }
  108.     i := 0;
  109.     repeat
  110.       i := i+1;
  111.     until
  112.       (ErrorMsgs[i].ErrNo = ExitCode) { found                                }
  113.       or (i = ErrorMsgSize);          { use 'Unknown error' message          }
  114.  
  115. { Now look for traceback information                                         }
  116. { i is the first local variable, use it to find local stack                  }
  117.     adr := ofs(i)+2;         { Get offset of bottom of our stack             }
  118.     _bp := memw[sseg:adr];   { Get old bp from stack                         }
  119.     found := false;
  120.     Errorcs := Seg(ErrorAddr^)+PrefixSeg+$10;
  121.                              { Convert relative segment to absolute          }
  122.     Errorip := Ofs(ErrorAddr^);
  123.     _cs := Errorcs;
  124.     _ip := Errorip;
  125.     { Look for far call to error-check routine - 'normal' errors             }
  126.     if (mem[_cs:_ip-5]= FarCallOpcode) { Found far call                      }
  127.       { It should be : far call to error-check routine,                      }
  128.       { then from it far call to our procedure                               }
  129.       { Compare segments                                                     }
  130.     and (memw[_cs:_ip-2] = memw[sseg:adr+4])
  131.       { Offsets differ by less than $80 - assume that was a call from        }
  132.       { error-check routine                                                  }
  133.     and (abs(integer(memw[_cs:_ip-4]-memw[sseg:adr+2]))<$80) then begin
  134.         found := true;
  135.     end;
  136.     { Not found, so it must be arithmetic (80x87) error }
  137.     if not found then begin
  138.     { First look for errors in initialization part of unit                   }
  139.     { Units have special entry sequence - no 'push bp' instruction           }
  140.       _ip := memw[sseg:_bp]; { Get return address from stack                 }
  141.       _cs := memw[sseg:_bp+2];
  142.       { First look for far call to erroneous routine }
  143.       if (mem[_cs:_ip-5]=FarCallOpCode) then begin
  144.         newip := memw[_cs:_ip-4];
  145.         _cs := memw[_cs:_ip-2];
  146.         { Look for special entry sequence }
  147.         if (memw[_cs:newip]=MovbpspOpcode) then begin
  148.           found := true;
  149.         end;
  150.       end;
  151.     end;
  152.     if not found then begin
  153.     { Now look for errors in procedure reached by far call                   }
  154.       _ip := memw[sseg:_bp+2]; { Get return address from stack (skip old bp) }
  155.       _cs := memw[sseg:_bp+4];
  156.       { First look for far call to erroneous routine }
  157.       if (mem[_cs:_ip-5]=FarCallOpcode) then begin
  158.         newip := memw[_cs:_ip-4];
  159.         _cs := memw[_cs:_ip-2];
  160.         { Look for standard entry sequence }
  161.         if (mem[_cs:newip]=PushbpOpcode) and (memw[_cs:newip+1]=MovbpspOpcode) then begin
  162.           found := true;
  163.         end;
  164.       end;
  165.     end;
  166.     if not found then
  167.     { Now look for errors in procedure reached by near call                   }
  168.     { This is tricky, because we don't know cs at the time of error -         }
  169.     { ErrorAdr gives only 'normalized pointer'. But it was pushed on stack    }
  170.     { somewhere by the actual 80x87 interrupt, so...                          }
  171.     repeat                   { look for old cs on stack                       }
  172.       _cs := memw[sseg:adr]; { try next word from stack for cs                }
  173.                              { ip is already taken from stack                 }
  174.       if mem[_cs:_ip-3]=NearCallOpcode then begin
  175.         newip := _ip+memw[_cs:_ip-2]; { Near calls are relative               }
  176.         { Look for standard entry sequence }
  177.         if (mem[_cs:newip]=PushbpOpcode) and (memw[_cs:newip+1]=MovbpspOpcode) then begin
  178.           found := true;
  179.         end;
  180.       end;
  181.       inc(adr,2);            { point to next word on stack                    }
  182.     until found or (adr>_bp);{ stop when stack ends                           }
  183.  
  184.     if not found then begin
  185.     { Nothing found on stack, so assume main program }
  186.       _cs := PrefixSeg+$10;
  187.       found := true;         { Always true!                                   }
  188.     end;
  189.  
  190.     if found then begin
  191.     { For 8087 errors, ErrorAdr is a 'normalized' pointer, so convert it     }
  192.       inc(Errorip,$10*(Errorcs-_cs));
  193.       Errorcs := _cs;
  194.     end;
  195.     { Write message, use relative segment }
  196.     writeln('Runtime error ',ExitCode,' at ',hex(Errorcs-PrefixSeg-$10),':',
  197.             hex(Errorip));
  198.     writeln(ErrorMsgs[i].ErrTxt);
  199.     if found then begin
  200.       first := true;
  201.       { Now loop thru traceback ...                                          }
  202.       repeat
  203.         found := false;
  204.         _ip := memw[sseg:_bp+2]-3; { point to assumed 'call' instruction      }
  205.         { try near call }
  206.         if mem[_cs:_ip]=NearCallOpcode then begin
  207.           newip := _ip+3+memw[_cs:_ip+1];
  208.           { Look for standard entry sequence }
  209.           if (mem[_cs:newip]=PushbpOpcode) and (memw[_cs:newip+1]=MovbpspOpcode) then begin
  210.             newcs := _cs;
  211.             found := true;
  212.             NF := 'N';
  213.           end;
  214.         end;
  215.         if not found then begin
  216.           _ip := _ip-2;      { Adjust for far call                            }
  217.           newcs := memw[sseg:_bp+4]; { Get cs                                 }
  218.           if mem[newcs:_ip]=FarCallOpcode then begin
  219.             { It should be call to cs at previous level, so check it          }
  220.             if (memw[newcs:_ip+3] = _cs) then begin
  221.               _cs := newcs;
  222.               newip := memw[_cs:_ip+1];
  223.               newcs := memw[_cs:_ip+3];
  224.               { Look for standard entry sequence }
  225.               if (mem[newcs:newip]=PushbpOpcode) and (memw[newcs:newip+1]=MovbpspOpcode) then begin
  226.                 found := true;
  227.                 NF := 'F';
  228.               end;
  229.             end;
  230.           end;
  231.         end;
  232.         if found then begin
  233.           if first then begin
  234.           { Here on first pass, but only if there is anything to print       }
  235.             writeln('Traceback');
  236.             first := false;
  237.           end;
  238.           { Write message, use relative segments again }
  239.           writeln(NF,' Procedure at ',hex(newcs-PrefixSeg-$10),':',hex(newip),
  240.                   ' Called from ',hex(_cs-PrefixSeg-$10),':',hex(_ip));
  241.           _bp := memw[sseg:_bp];
  242.         end;
  243.       until not found;
  244.     end;
  245.     if not Continue then
  246.       halt(ExitCode);        { Halt program                                  }
  247.   end; { if ExitCode<>0 }
  248.   { On normal exit, or if Continue = true, proceed to next ExitProc in chain }
  249.   ExitProc := ExitSave;
  250. end; { ErrorTrap }
  251.  
  252. begin
  253.   ExitSave := ExitProc;      { Save old pointer                              }
  254.   ExitProc := @ErrorTrap;    { Install our procedure                         }
  255. end.